home *** CD-ROM | disk | FTP | other *** search
Text File | 1990-10-25 | 93.6 KB | 3,728 lines | [TEXT/MPS ] |
- {$P}
- {[a-,body+,h-,o=100,r+,rec+,t=4,u+,#+,j=20/57/1$,n-]}
- { UDDialog.inc1.p }
- { Copyright © 1988-1990 Apple Computer Inc. All rights reserved. }
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgInit}
-
- PROCEDURE InitUDialog;
-
- BEGIN
- IF qTemplateViews THEN
- BEGIN
- { So the linker doesn't dead strip these }
- IF gDeadStripSuppression THEN
- BEGIN
- IF Member(TObject(NIL), TDialogView) THEN;
- IF Member(TObject(NIL), TControl) THEN;
- IF Member(TObject(NIL), TButton) THEN;
- IF Member(TObject(NIL), TCheckBox) THEN;
- IF Member(TObject(NIL), TRadio) THEN;
- IF Member(TObject(NIL), TCluster) THEN;
- IF Member(TObject(NIL), TIcon) THEN;
- IF Member(TObject(NIL), TPicture) THEN;
- IF Member(TObject(NIL), TPopup) THEN;
- IF Member(TObject(NIL), TStaticText) THEN;
- IF Member(TObject(NIL), TEditText) THEN;
- IF Member(TObject(NIL), TNumberText) THEN;
- IF Member(TObject(NIL), TPattern) THEN;
- END;
-
- RegisterStdType('TDialogView', kStdDialogView);
- RegisterStdType('TControl', kStdControl);
- RegisterStdType('TButton', kStdButton);
- RegisterStdType('TCheckBox', kStdCheckBox);
- RegisterStdType('TRadio', kStdRadio);
- RegisterStdType('TCluster', kStdCluster);
- RegisterStdType('TIcon', kStdIcon);
- RegisterStdType('TPicture', kStdPicture);
- RegisterStdType('TPopup', kStdPopup);
- RegisterStdType('TStaticText', kStdStaticText);
- RegisterStdType('TEditText', kStdEditText);
- RegisterStdType('TNumberText', kStdNumberText);
- RegisterStdType('TPattern', kStdPattern);
- END;
-
- gUDialogInitialized := TRUE;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE GetMenuColors(popupRect: Rect;
- menuID, itemNum: INTEGER;
- VAR fColor, bColor: RGBColor);
-
- VAR
- gotTitle: BOOLEAN;
- gdh: GDHandle;
- mce: MCEntryPtr;
- titleMce: MCEntry;
- globalMce: MCEntry;
-
- PROCEDURE SetBadColors;
-
- BEGIN
- fColor := gRGBBlack;
- bColor := gRGBWhite;
- END;
-
- BEGIN
- gotTitle := False; { Assume the worst. We always do. }
-
- IF EmptyRect(popupRect) THEN
- SetBadColors { Can't see it anyway so use B&W }
- ELSE IF qNeedsColorQD | gConfiguration.hasColorQD THEN { First, be sure we have color QD… }
- BEGIN
- LocalToGlobal(popupRect.topLeft); { Globalize rect, in focused coordinates }
- LocalToGlobal(popupRect.botRight);
- gdh := GetMaxDevice(popupRect); { Get device characteristics for that rect }
-
- IF (gdh <> NIL) & (gdh^^.gdPMap^^.pixelSize > 1) THEN { If we have more than two colors }
- BEGIN
- mce := GetMCEntry(menuID, 0); { Always get title entry }
- IF mce <> NIL THEN
- BEGIN
- gotTitle := TRUE;
- titleMce := mce^; { Future calls could shift memory }
- END;
-
- IF NOT gotTitle THEN { If we can't get the title entry, then… }
- BEGIN
- mce := GetMCEntry(0, 0); { …we'll need the global entry, too }
- IF mce <> NIL THEN
- globalMce := mce^
- ELSE
- BEGIN
- SetBadColors; { If no title, AND no global entry, punt }
- EXIT(GetMenuColors); { Even if item guy exists. No title, No
- washee }
- END;
- END;
-
- { Handle a title color request }
- IF itemNum = 0 THEN
- BEGIN
- IF gotTitle THEN
- BEGIN
- fColor := titleMce.mctRGB1;
- bColor := titleMce.mctRGB2;
- END
- ELSE { IF gotGlobal << has to be, by this point }
- BEGIN
- fColor := globalMce.mctRGB1;
- bColor := globalMce.mctRGB4;
- END;
- END
- { Otherwise, it's for an item }
- ELSE
- BEGIN
- mce := GetMCEntry(menuID, itemNum);
- IF mce <> NIL THEN
- fColor := mce^.mctRGB2
- ELSE IF gotTitle THEN
- fColor := titleMce.mctRGB3
- ELSE
- fColor := globalMce.mctRGB3;
-
- IF gotTitle THEN
- bColor := titleMce.mctRGB4
- ELSE
- bColor := globalMce.mctRGB2;
- END;
- END
- ELSE
- SetBadColors; { Only one bit depth. Default to B&W }
- END
- ELSE
- SetBadColors; { Not using Color QuickDraw. B&W for sure }
-
- {$IFC qDebug}
- IF gIntenseDebugging THEN
- BEGIN
- IF itemNum = 0 THEN
- WRITE('Title ')
- ELSE
- WRITE('Item #', itemNum: 0);
- WRITELN(' foreground color- R:', fColor.red: 0, ', G:', fColor.green: 0, ', B:',
- fColor.blue: 0);
- IF itemNum = 0 THEN
- WRITE('Title ')
- ELSE
- WRITE('Item #', itemNum: 0);
- WRITELN(' background color- R:', bColor.red: 0, ', G:', bColor.green: 0, ', B:',
- bColor.blue: 0);
- END;
- {$ENDC}
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TDialogView.IDialogView(itsDocument: TDocument;
- itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsDefItemID, itsCancelItemID: IDType);
-
- VAR
- anAssociation: TAssociation;
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- {$IFC qDebug}
- IF NOT gUDialogInitialized THEN
- BEGIN
- ProgramBreak('InitUDialog must be called before creating a Dialog View.');
- Failure(noErr, 0);
- END;
- {$ENDC}
-
- fParamTxt := NIL; { In case of a catastrophe }
- fTEView := NIL; { Ditto. }
- IView(itsDocument, itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
-
- CatchFailures(fi, HandleFailure);
- New(anAssociation); { Okay to allocate list now }
- FailNIL(anAssociation);
- anAssociation.IAssociation;
- fParamTxt := anAssociation;
- fDefaultItem := itsDefItemID;
- fCancelItem := itsCancelItemID;
- fCurrentEditText := NIL;
- fDismissed := False;
- fDismisser := kNoIdentifier;
-
- fTEView := MakeTEView;
- Success(fi);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TDialogView.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- anAssociation: TAssociation;
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- {$IFC qDebug}
- IF NOT gUDialogInitialized THEN
- BEGIN
- ProgramBreak('InitUDialog must be called before creating a Dialog View.');
- Failure(noErr, 0);
- END;
- {$ENDC}
-
- fParamTxt := NIL; { In case of a catastrophe }
- fTEView := NIL; { Ditto. }
- INHERITED IRes(itsDocument, itsSuperView, itsParams);
- WITH DialogViewTemplatePtr(itsParams)^ DO
- BEGIN
- fDefaultItem := defaultItem;
- fCancelItem := cancelItem;
- END;
- CatchFailures(fi, HandleFailure);
- New(anAssociation); { Okay to allocate list now }
- FailNIL(anAssociation);
- anAssociation.IAssociation;
- fParamTxt := anAssociation;
- fCurrentEditText := NIL;
- fDismissed := False;
- fDismisser := kNoIdentifier;
-
- fTEView := MakeTEView;
- Success(fi);
-
- OffsetPtr(itsParams, SIZEOF(DialogViewTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TDialogView.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- dgPtr: DialogViewTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- dgPtr := DialogViewTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(DialogViewTemplate)));
-
- WITH dgPtr^ DO
- BEGIN
- defaultItem := fDefaultItem;
- cancelItem := fCancelItem;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TDialogView.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'dlog'; gWResType := 'TDialogView';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TDialogView.Free; OVERRIDE;
-
- VAR
- itsTEView: TDialogTEView;
-
- BEGIN
- FreeIfObject(fParamTxt);
- fParamTxt := NIL;
-
- { We postpone freeing fTEView because we don't know if it's still associated with an
- edittext view. (At this point it normally wouldn't be associated with an edittext,
- but you never know… So, free it after we've free'd all our subviews, including
- any edittext view that fTEView might be associated with. We also disassociated from
- its superview, if any, to avoid having free'd for us by INHERITED Free. }
-
- itsTEView := fTEView; { Can't refer to fTEView after calling
- INHERITED Free }
- fTEView := NIL;
-
- IF (itsTEView <> NIL) & (itsTEView.fSuperView <> NIL) THEN
- itsTEView.fSuperView.RemoveSubView(itsTEView);
-
- INHERITED Free;
-
- FreeIfObject(itsTEView); { Now free this puppy }
- itsTEView := NIL;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.CanDismiss(dismissing: IDType): BOOLEAN;
-
- VAR
- dismissingView: TView;
- successful: BOOLEAN;
-
- BEGIN
- { First, make sure the view initiating the the dismissal, if any, is enabled. }
-
- IF LONGINT(dismissing) <> LONGINT(kNoIdentifier) THEN
- dismissingView := FindSubView(dismissing)
- ELSE
- dismissingView := NIL; { no dismissing view }
-
- { Thanks Tommi GESSL }
- successful := (dismissingView = NIL) | (dismissingView.IsViewEnabled);
- CanDismiss := successful;
-
- IF successful THEN { test only we haven´t failed }
- { Now, if we're not cancelling, make sure the current edit text is valid and
- return false if it isn't.}
-
- IF (LONGINT(fCancelItem) = LONGINT(kNoIdentifier)) | (dismissing <> fCancelItem) THEN
- BEGIN
- DoSelectEditText(NIL, False); { Attempt to deselect current edit text }
- CanDismiss := fCurrentEditText = NIL; { Successful only if it was deselected }
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TDialogView.CantDeselect(theEditText: TEditText;
- reason: LONGINT);
-
- VAR
- aString: Str255;
-
- BEGIN
- IF reason <> kValidValue THEN
- BEGIN
- IF reason <> kErrorHandled THEN { go ahead and post an alert }
- BEGIN
- IF (reason < 1) | (reason > kNoOfDefaultReasons) THEN
- reason := kInvalidValue;
-
- GetIndString(aString, kInvalidValueReasons, reason);
- ParamText(aString, '', '', '');
- StdAlert(phInvalidValue);
- END;
- aString := theEditText.fDataHandle^^; { Restart with previous value }
- theEditText.RestartEdit(aString);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TDialogView.Close; OVERRIDE;
-
- BEGIN
- IF LONGINT(fDismisser) = LONGINT(kNoIdentifier) THEN
- DismissDialog(kNoIdentifier);
-
- INHERITED Close;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.DeselectCurrentEditText: BOOLEAN;
-
- VAR
- validateResult: LONGINT;
- itsWindow: TWindow;
- lastCommand: TCommand;
-
- BEGIN
- DeselectCurrentEditText := TRUE;
-
- IF fCurrentEditText <> NIL THEN
- BEGIN
- { Commit the last command to prevent undo from applying to the wrong edit text,
- and to ensure that all changes are made before validating. }
- IF (fTEView <> NIL) THEN
- BEGIN
- lastCommand := fTEView.GetLastCommand;
- IF (lastCommand <> NIL) & (lastCommand.fView = fTEView) THEN
- fTEView.CommitLastCommand;
- END;
-
- validateResult := fCurrentEditText.Validate;
- IF validateResult = kValidValue THEN
- BEGIN
- fCurrentEditText.StopEdit;
- fCurrentEditText := NIL; { No edit text is selected }
- itsWindow := GetWindow; { Patch up the target change }
- IF itsWindow <> NIL THEN
- itsWindow.SetTarget(SELF)
- ELSE
- gApplication.SetTarget(gApplication);
- END
- ELSE
- BEGIN
- CantDeselect(fCurrentEditText, validateResult);
- DeselectCurrentEditText := False;
- END;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TDialogView.DismissDialog(dismisser: IDType);
-
- VAR
- dismissingControl: TControl;
-
- BEGIN
- IF NOT fDismissed THEN
- IF CanDismiss(dismisser) THEN
- BEGIN
- fDismissed := TRUE;
- fDismisser := dismisser;
- END
- ELSE
- Failure(noErr, 0); { Silent failure }
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.DoChoice(origView: TView;
- itsChoice: INTEGER); OVERRIDE;
-
- BEGIN
- CASE itsChoice OF
- mEditTextHit:
- BEGIN
- {$IFC qDebug}
- IF NOT Member(origView, TEditText) THEN
- ProgramBreak('Got mEditTextHit on non-TEditText view.')
- ELSE
- {$ENDC}
- DoSelectEditText(TEditText(origView), False);
- END;
- OTHERWISE
- IF Member(origView, TControl) & TControl(origView).fDismissesDialog THEN
- DismissDialog(origView.fIdentifier)
- ELSE
- INHERITED DoChoice(origView, itsChoice);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.DoCommandKey(ch: CHAR;
- VAR info: EventInfo): TCommand; OVERRIDE;
-
- VAR
- cancelView: TView;
-
- BEGIN
- IF IsViewEnabled & (ch = '.') & (LONGINT(fCancelItem) <> LONGINT(kNoIdentifier)) THEN
- BEGIN
- cancelView := FindSubView(fCancelItem);
- IF (cancelView <> NIL) & Member(cancelView, TControl) THEN
- BEGIN
- IF cancelView.IsViewEnabled THEN
- TControl(cancelView).Flash;
- TControl(cancelView).DoChoice(cancelView, TControl(cancelView).fDefChoice);
- END
- ELSE
- DoChoice(cancelView, mCancelKey);
- DoCommandKey := NIL;
- END
- ELSE
- DoCommandKey := INHERITED DoCommandKey(ch, info);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.DoKeyCommand(ch: CHAR;
- aKeyCode: INTEGER;
- VAR info: EventInfo): TCommand; OVERRIDE;
-
- VAR
- defaultView: TView;
- cancelView: TView;
-
- BEGIN
- { If we get this far, nobody's handled the Tab, Enter, or Return keys, so we will }
- DoKeyCommand := NIL;
- IF IsViewEnabled THEN
- CASE ch OF
- chEscape:
- IF aKeyCode = kClearVirtualCode THEN { esc double for two different keys! }
- DoKeyCommand := INHERITED DoKeyCommand(ch, aKeyCode, info)
- ELSE IF LONGINT(fCancelItem) <> LONGINT(kNoIdentifier) THEN
- BEGIN
- cancelView := FindSubView(fCancelItem);
- IF (cancelView <> NIL) & Member(cancelView, TControl) THEN
- BEGIN
- IF cancelView.IsViewEnabled THEN
- TControl(cancelView).Flash;
- TControl(cancelView).DoChoice(cancelView, TControl(cancelView).fDefChoice);
- END
- ELSE
- DoChoice(cancelView, mCancelKey);
- END
- ELSE
- DoKeyCommand := INHERITED DoKeyCommand(ch, aKeyCode, info);
- chTab:
- Tab(info.theShiftKey);
- chEnter, chReturn:
- IF LONGINT(fDefaultItem) <> LONGINT(kNoIdentifier) THEN
- BEGIN
- defaultView := FindSubView(fDefaultItem);
- IF (defaultView <> NIL) & Member(defaultView, TControl) THEN
- BEGIN
- IF defaultView.IsViewEnabled THEN
- TControl(defaultView).Flash;
- TControl(defaultView).DoChoice(defaultView, TControl(defaultView).fDefChoice);
- END
- ELSE
- DoChoice(defaultView, mDefaultKey);
- END
- ELSE
- DoKeyCommand := INHERITED DoKeyCommand(ch, aKeyCode, info);
- OTHERWISE
- DoKeyCommand := INHERITED DoKeyCommand(ch, aKeyCode, info);
- END
- ELSE
- DoKeyCommand := INHERITED DoKeyCommand(ch, aKeyCode, info);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.DoSelectEditText(theEditText: TEditText;
- selectChars: BOOLEAN);
-
- VAR
- itsWindow: TWindow;
-
- BEGIN
- IF theEditText <> fCurrentEditText THEN { If we're not editing this view… }
- BEGIN
- IF DeselectCurrentEditText THEN
- BEGIN
- fCurrentEditText := theEditText;
- IF theEditText <> NIL THEN
- BEGIN
- IF theEditText.fViewEnabled THEN
- theEditText.StartEdit(selectChars, fTEView)
- {$IFC qDebug}
- ELSE
- ProgramBreak('Attempt to select a disabled edit text view')
- {$ENDC}
- ;
- END
- ELSE
- BEGIN
- itsWindow := GetWindow; { Set the window's target to self }
- IF itsWindow <> NIL THEN
- itsWindow.SetTarget(SELF);
- END;
- END;
- END
- ELSE IF selectChars & (theEditText <> NIL) THEN { Make sure all the chars are selected. }
- theEditText.SetSelection(0, MAXINT, kRedraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.EachEditText(PROCEDURE DoToEditText(theEditText: TEditText));
-
- PROCEDURE CheckSubView(theSubView: TView);
-
- BEGIN
- IF Member(theSubView, TEditText) THEN
- DoToEditText(TEditText(theSubView))
- ELSE
- theSubView.EachSubView(CheckSubView);
- END;
-
- BEGIN
- EachSubView(CheckSubView);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.GetDialogView: TView; OVERRIDE;
-
- BEGIN
- GetDialogView := SELF;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.Tab(tabBackward: BOOLEAN);
-
- VAR
- first: TEditText;
- last: TEditText;
- next: TEditText;
- previous: TEditText;
-
- BEGIN
- SurveyEditText(first, last, next, previous);
-
- IF tabBackward THEN
- next := previous;
-
- IF next <> NIL THEN
- DoSelectEditText(next, TRUE);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- FUNCTION TDialogView.MakeTEView: TDialogTEView;
-
- VAR
- aDialogTEView: TDialogTEView;
-
- BEGIN
- New(aDialogTEView);
- FailNIL(aDialogTEView);
- aDialogTEView.IDialogTEView(NIL, NIL, gZeroVPt, gZeroVPt, sizeRelSuperView, sizeVariable,
- gZeroRect, gSystemStyle, teJustSystem, kWithoutStyle, False);
-
- aDialogTEView.fMinAhead := 1; { Don't _jump_ the view ahead when autoscrolling for
- scrollselectionintoview }
-
- MakeTEView := aDialogTEView;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAOpen}
-
- PROCEDURE TDialogView.DoOpen;
-
- VAR
- itsWindow: TWindow;
-
- BEGIN
- itsWindow := GetWindow;
- IF (itsWindow <> NIL) & Member(itsWindow.fTarget, TEditText) THEN
- { If the window's target is an edit text view, and that edit text view is installed
- in this dialog, then select it. Note that this can be problematic if the edit
- text view is in nested dialog views. }
- WITH itsWindow DO
- IF FindSubView(TEditText(fTarget).fIdentifier) = fTarget THEN
- DoSelectEditText(TEditText(fTarget), TRUE);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAOpen}
-
- PROCEDURE TDialogView.Open; OVERRIDE;
-
- BEGIN
- fDismissed := False;
- fDismisser := kNoIdentifier;
- DoOpen;
- INHERITED Open;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.ParamTxt(keyStr, valueStr: Str255);
-
- BEGIN
- fParamTxt.InsertEntry(keyStr, valueStr);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TDialogView.PoseModally: IDType;
-
- LABEL 1;
-
- VAR
- itsWindow: TWindow;
- fi: FailInfo;
-
- PROCEDURE HdlPoseModally(error: OSErr;
- message: LONGINT);
-
- BEGIN
- IF error = noErr THEN
- GOTO 1 { If no error then keep the dialog running }
- ELSE
- BEGIN
- fDismissed := TRUE; { Avoid validating selected edit text }
- itsWindow.Close; { If an error then close the dialog and exit
- via failure mechanism }
- END;
- END;
-
- BEGIN
- itsWindow := GetWindow;
- IF itsWindow <> NIL THEN
- BEGIN
- gApplication.CommitLastCommand; { Make sure that the undo menu reflects }
- { the view being looked at. Otherwise }
- { the undo menu will be wrong. }
-
- itsWindow.Open;
- itsWindow.Select; { Bring it to the front }
-
- fDismissed := False;
- REPEAT
- CatchFailures(fi, HdlPoseModally);
- gApplication.PollEvent(kAllowApplicationToSleep);
- Success(fi);
- 1:
- UNTIL fDismissed;
- PoseModally := fDismisser;
-
- END
- ELSE
- PoseModally := kNoIdentifier;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.ReplaceText(VAR theText: Str255);
-
- PROCEDURE ReplaceOnce(item: TEntry);
-
- VAR
- index: INTEGER;
-
- BEGIN
- WITH item DO
- REPEAT
- index := Pos(fKey^^, theText);
- IF index > 0 THEN
- BEGIN
- Delete(theText, index, Length(fKey^^));
- IF Length(theText) + Length(fValue^^) < SIZEOF(Str255) THEN
- Insert(fValue^^, theText, index);
- END;
- UNTIL index = 0;
- END;
-
- BEGIN
- fParamTxt.fEntries.Each(ReplaceOnce);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.SelectEditText(itsIdentifier: IDType;
- selectChars: BOOLEAN);
-
- VAR
- aSubView: TView;
-
- BEGIN
- aSubView := FindSubView(itsIdentifier);
- IF (aSubView <> NIL) & (Member(aSubView, TEditText)) THEN
- DoSelectEditText(TEditText(aSubView), selectChars);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TDialogView.SurveyEditText(VAR first, last, next, previous: TEditText);
-
- VAR
- foundCurrent: BOOLEAN;
-
- PROCEDURE Survey(theEditText: TEditText);
-
- BEGIN
- IF theEditText.fViewEnabled & theEditText.fShown THEN
- BEGIN
- IF first = NIL THEN
- first := theEditText;
- last := theEditText;
- IF theEditText = fCurrentEditText THEN
- foundCurrent := TRUE
- ELSE IF foundCurrent & (next = NIL) THEN
- next := theEditText;
- IF NOT foundCurrent THEN
- previous := theEditText;
- END;
- END;
-
- BEGIN
- foundCurrent := False;
- next := NIL;
- previous := NIL;
- first := NIL;
- last := NIL;
- EachEditText(Survey);
- IF next = NIL THEN
- next := first;
- IF previous = NIL THEN
- previous := last;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TDialogView.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TDialogView', NIL, bClass);
- DoToField('fDefaultItem', @fDefaultItem, bIDType);
- DoToField('fCancelItem', @fCancelItem, bIDType);
- DoToField('fParamTxt', @fParamTxt, bObject);
- DoToField('fCurrentEditText', @fCurrentEditText, bObject);
- DoToField('fTEView', @fTEView, bObject);
- DoToField('fDismissed', @fDismissed, bBoolean);
- DoToField('fDismisser', @fDismisser, bIDType);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TButton.IButton(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsLabel: Str255);
-
- BEGIN
- ICtlMgr(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet, itsLabel, 0, 0, 0,
- pushButProc);
- fDefChoice := mButtonHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TButton.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- itsArea: Rect;
-
- BEGIN
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fDefChoice := mButtonHit;
- ControlArea(itsArea);
- WITH ButtonTemplatePtr(itsParams)^ DO
- CreateCMgrControl(itsArea, itsLabel, 0, 0, 0, pushButProc);
-
- OffsetPtrWStr(itsParams, SIZEOF(ButtonTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TButton.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- theLabel: Str255;
- btPtr: ButtonTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- GetText(theLabel);
-
- btPtr := ButtonTemplatePtr(ExpandPtrWStr(theResource, itsParams, SIZEOF(ButtonTemplate),
- Length(theLabel)));
-
- { btPtr^.itsLabel := theLabel; }
- CopyStr255(theLabel, PRStr(btPtr^.itsLabel));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TButton.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'butn'; gWResType := 'TButton';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TButton.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TButton', NIL, bClass);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TCheckBox.ICheckBox(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsLabel: Str255;
- isTurnedOn: BOOLEAN);
-
- BEGIN
- ICtlMgr(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet, itsLabel, 0, 0, 1,
- checkBoxProc);
- SetState(isTurnedOn, kDontRedraw);
- fDefChoice := mCheckBoxHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TCheckBox.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- itsArea: Rect;
-
- BEGIN
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fDefChoice := mCheckBoxHit;
- ControlArea(itsArea);
- WITH CheckBoxTemplatePtr(itsParams)^ DO
- CreateCMgrControl(itsArea, itsLabel, ORD(isOn), 0, 1, checkBoxProc);
-
- OffsetPtrWStr(itsParams, SIZEOF(CheckBoxTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TCheckBox.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- theLabel: Str255;
- cbPtr: CheckBoxTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- GetText(theLabel);
-
- cbPtr := CheckBoxTemplatePtr(ExpandPtrWStr(theResource, itsParams, SIZEOF(CheckBoxTemplate),
- Length(theLabel)));
-
- cbPtr^.isOn := isOn;
- { cbPtr^.itsLabel := theLabel; }
- CopyStr255(theLabel, PRStr(cbPtr^.itsLabel));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TCheckBox.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'chkb'; gWResType := 'TCheckBox';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCheckBox.DoChoice(origView: TView;
- itsChoice: INTEGER);
-
- BEGIN
- IF itsChoice = mCheckBoxHit THEN
- Toggle(kRedraw);
- INHERITED DoChoice(origView, itsChoice);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TCheckBox.isOn: BOOLEAN;
-
- BEGIN
- isOn := GetLongVal <> 0;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCheckBox.SetState(state, redraw: BOOLEAN);
-
- BEGIN
- SetLongVal(ORD(state), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCheckBox.Toggle(redraw: BOOLEAN);
-
- BEGIN
- SetLongVal(ORD(NOT isOn), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCheckBox.ToggleIf(matchState, redraw: BOOLEAN);
-
- BEGIN
- IF isOn = matchState THEN
- SetLongVal(ORD(NOT isOn), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TCheckBox.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TCheckBox', NIL, bClass);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TRadio.IRadio(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsLabel: Str255;
- isTurnedOn: BOOLEAN);
-
- BEGIN
- ICtlMgr(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet, itsLabel, 0, 0, 1,
- radioButProc);
- SetState(isTurnedOn, kDontRedraw);
- fDefChoice := mRadioHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TRadio.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- itsArea: Rect;
-
- BEGIN
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fDefChoice := mRadioHit;
- ControlArea(itsArea);
- WITH RadioTemplatePtr(itsParams)^ DO
- CreateCMgrControl(itsArea, itsLabel, ORD(isOn), 0, 1, radioButProc);
- OffsetPtrWStr(itsParams, SIZEOF(RadioTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TRadio.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- theLabel: Str255;
- rdPtr: RadioTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- GetText(theLabel);
-
- rdPtr := RadioTemplatePtr(ExpandPtrWStr(theResource, itsParams, SIZEOF(RadioTemplate),
- Length(theLabel)));
-
- rdPtr^.isOn := isOn;
- { rdPtr^.itsLabel := theLabel; }
- CopyStr255(theLabel, PRStr(rdPtr^.itsLabel));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TRadio.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'radb'; gWResType := 'TRadio';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TRadio.DoChoice(origView: TView;
- itsChoice: INTEGER);
-
- BEGIN
- IF (itsChoice = mRadioHit) & NOT isOn THEN
- Toggle(kRedraw);
- INHERITED DoChoice(origView, itsChoice);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TRadio.isOn: BOOLEAN;
-
- BEGIN
- isOn := GetLongVal <> 0;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TRadio.SetState(state, redraw: BOOLEAN);
-
- BEGIN
- SetLongVal(ORD(state), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TRadio.Toggle(redraw: BOOLEAN);
-
- BEGIN
- SetLongVal(ORD(NOT isOn), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TRadio.ToggleIf(matchState, redraw: BOOLEAN);
-
- BEGIN
- IF isOn = matchState THEN
- SetLongVal(ORD(NOT isOn), redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TRadio.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TRadio', NIL, bClass);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TCluster.ICluster(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID, itsIndex: INTEGER);
-
- VAR
- aString: Str255;
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
- fRsrcID := itsRsrcID;
- fIndex := itsIndex;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- GetIndString(aString, fRsrcID, fIndex);
- FailResError;
- Success(fi);
- SetLabel(aString, kDontRedraw);
- END;
- ViewEnable(False, kDontRedraw); { Default is not to enable hit testing }
- fDefChoice := mClusterHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TCluster.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- fDataHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
- fDefChoice := mClusterHit;
-
- WITH ClusterTemplatePtr(itsParams)^ DO
- SetLabel(itsLabel, kDontRedraw);
-
- OffsetPtrWStr(itsParams, SIZEOF(ClusterTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TCluster.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- theLabel: Str255;
- clPtr: ClusterTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- GetLabel(theLabel);
-
- clPtr := ClusterTemplatePtr(ExpandPtrWStr(theResource, itsParams, SIZEOF(ClusterTemplate),
- Length(theLabel)));
-
- { clPtr^.itsLabel := theLabel; }
- CopyStr255(theLabel, PRStr(clPtr^.itsLabel));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TCluster.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'clus'; gWResType := 'TCluster';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TCluster.Free; OVERRIDE;
-
- BEGIN
- ReleaseLabel;
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCluster.DoChoice(origView: TView;
- itsChoice: INTEGER); OVERRIDE;
-
- PROCEDURE ResetRadios(aView: TView);
-
- BEGIN
- IF Member(aView, TRadio) & { If the subview is a TRadio, and… }
- (aView <> origView) THEN { …it's not the calling radio… }
- TRadio(aView).SetState(False, kRedraw); { …set it off and redraw it }
- END;
-
- BEGIN
- IF (itsChoice = mRadioHit) & { If we got this far, a radio's changed
- state }
- (origView.fSuperView = SELF) THEN { Only worry about it if it's our subview! }
- EachSubView(ResetRadios); { Reset everybody except the calling radio }
- INHERITED DoChoice(origView, itsChoice);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TCluster.Draw(area: Rect); OVERRIDE;
-
- VAR
- fontHt: INTEGER;
- labelWd: INTEGER;
- oldTop: INTEGER;
- fInfo: FontInfo;
- theFrame: Rect;
- theText: Str255;
- aDialogView: TDialogView;
- aTextStyle: TextStyle;
-
- BEGIN
- IF qDebug THEN
- AssumeFocused;
-
- IF fDataHandle <> NIL THEN
- BEGIN
- {$Push} {$H-}
- WITH fPenSize DO
- PenSize(h, v);
- {$Pop}
- GetFontInfo(fInfo); { Determine label's height }
- WITH fInfo DO
- fontHt := ascent + descent + leading;
- ControlArea(theFrame); { Get the control's extent }
- oldTop := theFrame.top;
- {$Push} {$H-}
- WITH fPenSize DO
- InsetRect(theFrame, h + 1, v + 1); { Inset the frame a little }
- {$Pop}
- theFrame.top := oldTop + BSR(fontHt, 1); { Bump top so it cuts label in half }
-
- FrameRect(theFrame); { Draw the frame }
-
- CopyStr255(fDataHandle^^, @theText);
- aDialogView := TDialogView(GetDialogView);
- IF aDialogView <> NIL THEN
- aDialogView.ReplaceText(theText);
-
- { !!! Really need a method to draw the title }
- labelWd := StringWidth(theText) + 8;
- SetRect(theFrame, 16, 0, labelWd + 16, fontHt);
- MATextBox(Ptr(ORD4(@theText) + 1), Length(theText), theFrame, teJustCenter, kNoAutoWrap, NIL,
- kEraseFirst, kNoSpaceForCaret);
- END;
- INHERITED Draw(area); { Let parents have a chance to draw too }
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TCluster.GetLabel(VAR theLabel: Str255);
-
- BEGIN
- IF fDataHandle <> NIL THEN
- theLabel := fDataHandle^^
- ELSE
- theLabel := '';
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TCluster.ReleaseLabel;
-
- BEGIN
- Handle(fDataHandle) := DisposeIfHandle(fDataHandle);
-
- fRsrcID := kNoResource;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TCluster.ReportCurrent: IDType;
-
- VAR
- rView: TView;
-
- FUNCTION FindRadio(aView: TView): BOOLEAN;
-
- BEGIN
- FindRadio := Member(aView, TRadio) & TRadio(aView).isOn;
- END;
-
- BEGIN
- rView := FirstSubViewThat(FindRadio);
- IF rView <> NIL THEN
- ReportCurrent := rView.fIdentifier
- ELSE
- ReportCurrent := kNoIdentifier;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TCluster.SetLabel(theLabel: Str255;
- redraw: BOOLEAN);
-
- BEGIN
- ReleaseLabel;
- IF theLabel <> '' THEN
- BEGIN
- fDataHandle := NewString(theLabel);
- IF MemError <> noErr THEN
- fDataHandle := NIL;
- END;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TCluster.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- VAR
- aString: Str255;
-
- BEGIN
- DoToField('TCluster', NIL, bClass);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fIndex', @fIndex, bInteger);
- DoToField('fDataHandle', @fDataHandle, bHandle);
- IF fDataHandle <> NIL THEN
- BEGIN
- aString := fDataHandle^^;
- DoToField('fDataHandle^^', @aString, bString);
- END;
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TIcon.IIcon(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID: INTEGER;
- preferColor: BOOLEAN);
-
- VAR
- fi: FailInfo;
- itsRsrcHandle: Handle;
- savedState: SignedByte;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
- fPreferColor := preferColor;
- fRsrcID := itsRsrcID;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- IF fPreferColor THEN
- IF qNeedsColorQD | gConfiguration.hasColorQD THEN
- BEGIN
- { make the 'cicn' resource non-purgeable, so the Toolbox doesn't die }
- itsRsrcHandle := GetResource('cicn', fRsrcID);
- IF itsRsrcHandle <> NIL THEN
- BEGIN
- savedState := HGetState(itsRsrcHandle);
- HNoPurge(itsRsrcHandle);
- END;
-
- fDataHandle := Handle(GetCIcon(fRsrcID));
-
- { restore the state of the 'cicn' resource }
- IF itsRsrcHandle <> NIL THEN
- HSetState(itsRsrcHandle, savedState);
- END;
- IF fDataHandle = NIL THEN
- BEGIN
- fDataHandle := GetIcon(fRsrcID);
- IF fDataHandle <> NIL THEN
- fPreferColor := NOT kPreferColor; { Either can't or won't }
- END;
- FailResError;
- Success(fi);
- END;
- ViewEnable(False, kDontRedraw); { Default is to not enable hit testing }
- fDefChoice := mIconHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TIcon.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- fi: FailInfo;
- itsRsrcHandle: Handle;
- savedState: SignedByte;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- WITH IconTemplatePtr(itsParams)^ DO
- BEGIN
- fPreferColor := preferColor;
- fRsrcID := rsrcID;
- END;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- IF fPreferColor THEN
- IF qNeedsColorQD | gConfiguration.hasColorQD THEN
- BEGIN
- { make the 'cicn' resource non-purgeable, so the Toolbox doesn't die }
- itsRsrcHandle := GetResource('cicn', fRsrcID);
- IF itsRsrcHandle <> NIL THEN
- BEGIN
- savedState := HGetState(itsRsrcHandle);
- HNoPurge(itsRsrcHandle);
- END;
-
- fDataHandle := Handle(GetCIcon(fRsrcID));
-
- { restore the state of the 'cicn' resource }
- IF itsRsrcHandle <> NIL THEN
- HSetState(itsRsrcHandle, savedState);
- END;
- IF fDataHandle = NIL THEN
- BEGIN
- fDataHandle := GetIcon(fRsrcID);
- IF fDataHandle <> NIL THEN
- fPreferColor := NOT kPreferColor; { Either can't or won't }
- END;
- { Don't die because resource not found - just return NIL handle }
- FailResError;
- Success(fi);
- END;
- fDefChoice := mIconHit;
-
- OffsetPtr(itsParams, SIZEOF(IconTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TIcon.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- icPtr: IconTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- icPtr := IconTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(IconTemplate)));
-
- WITH icPtr^ DO
- BEGIN
- preferColor := fPreferColor;
- {$IFC qDebug}
- IF fRsrcID = kNoResource THEN
- WRITELN('Tried to write TIcon with no resource ID.');
- {$ENDC}
- rsrcID := fRsrcID;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TIcon.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'icon'; gWResType := 'TIcon';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TIcon.Free; OVERRIDE;
-
- BEGIN
- ReleaseIcon;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TIcon.Draw(area: Rect); OVERRIDE;
-
- VAR
- oldState: SignedByte;
- theRect: Rect;
- aPixMap: PixMap;
- aBitMapPtr: BitMapPtr;
- srcRect: Rect;
-
- BEGIN
- IF fDataHandle <> NIL THEN
- BEGIN
- IF fRsrcID <> kNoResource THEN
- LoadResource(fDataHandle);
- IF fDataHandle^ <> NIL THEN { If there's room for the icon… }
- BEGIN
- PenNormal; { NECESSARY? }
- ControlArea(theRect);
- oldState := GetHandleBits(fDataHandle);
- HNoPurge(fDataHandle);
- HLock(fDataHandle);
-
- IF fPreferColor THEN
- BEGIN
-
- { We can't use PlotCIcon here because it can't be written to a picture }
- { and when WriteToDeskScrap is called, the icon is plotted on the }
- { desktop rather than in the picture. So instead, pick apart the color }
- { icon handle and use copybits, ignoring the mask. }
-
- aPixMap := CIconHandle(fDataHandle)^^.iconPMap;
- HLock(CIconHandle(fDataHandle)^^.iconData);
- aPixMap.baseAddr := CIconHandle(fDataHandle)^^.iconData^;
- srcRect := aPixMap.bounds;
- aBitMapPtr := @aPixMap;
- CopyBits(aBitMapPtr^, thePort^.portBits, srcRect, theRect, srcCopy, NIL);
- HUnLock(CIconHandle(fDataHandle)^^.iconData);
- END
- ELSE
- PlotIcon(theRect, fDataHandle);
-
- SetHandleBits(fDataHandle, oldState);
- END;
- END;
-
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TIcon.ReleaseIcon;
-
- BEGIN
- fRsrcID := kNoResource;
- IF fDataHandle <> NIL THEN
- BEGIN
- IF fPreferColor THEN
- DisposCIcon(CIconHandle(fDataHandle))
- ELSE
- HPurge(fDataHandle);
- fDataHandle := NIL;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TIcon.SetIcon(theIcon: Handle;
- redraw: BOOLEAN);
- CONST
- kBWIconSize = 128;
-
- BEGIN
- ReleaseIcon;
-
- IF GetHandleSize(theIcon) <> kBWIconSize THEN
- fPreferColor := TRUE
- ELSE
- fPreferColor := FALSE;
-
- fDataHandle := theIcon;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TIcon.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TIcon', NIL, bClass);
- DoToField('fPreferColor', @fPreferColor, bBoolean);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fDataHandle', @fDataHandle, bHandle);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPattern.IPattern(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID: INTEGER;
- preferColor: BOOLEAN);
-
- VAR
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
- fPreferColor := preferColor;
- fRsrcID := itsRsrcID;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- IF fPreferColor THEN
- IF qNeedsColorQD | gConfiguration.hasColorQD THEN
- fDataHandle := Handle(GetPixPat(fRsrcID));
- IF fDataHandle = NIL THEN
- BEGIN
- fDataHandle := Handle(GetPattern(fRsrcID));
- IF fDataHandle <> NIL THEN
- fPreferColor := NOT kPreferColor; { Either can't or won't }
- END;
- FailResError;
- Success(fi);
- END;
- ViewEnable(False, kDontRedraw); { Default is to not enable hit testing }
- fDefChoice := mPatternHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPattern.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- WITH PatternTemplatePtr(itsParams)^ DO
- BEGIN
- fPreferColor := preferColor;
- fRsrcID := rsrcID;
- END;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- IF fPreferColor THEN
- IF qNeedsColorQD | gConfiguration.hasColorQD THEN
- fDataHandle := Handle(GetPixPat(fRsrcID));
- IF fDataHandle = NIL THEN
- BEGIN
- fDataHandle := Handle(GetPattern(fRsrcID));
- IF fDataHandle <> NIL THEN
- fPreferColor := NOT kPreferColor; { Either can't or won't }
- END;
- FailResError;
- Success(fi);
- END;
- fDefChoice := mPatternHit;
-
- OffsetPtr(itsParams, SIZEOF(PatternTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPattern.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- ptPtr: PatternTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- ptPtr := PatternTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(PatternTemplate)));
-
- WITH ptPtr^ DO
- BEGIN
- preferColor := fPreferColor;
- {$IFC qDebug}
- IF fRsrcID = kNoResource THEN
- WRITELN('Tried to write TPattern with no resource ID.');
- {$ENDC}
- rsrcID := fRsrcID;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPattern.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'patn'; gWResType := 'TPattern';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TPattern.Free; OVERRIDE;
-
- BEGIN
- ReleasePattern;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPattern.Draw(area: Rect); OVERRIDE;
-
- VAR
- wasLocked: BOOLEAN;
- theRect: Rect;
-
- BEGIN
- IF fDataHandle <> NIL THEN
- BEGIN
- IF (fRsrcID <> kNoResource) & NOT fPreferColor THEN { Pixpat handles <> resource handles }
- LoadResource(fDataHandle);
- IF fDataHandle^ <> NIL THEN { If there's room for the pattern… }
- BEGIN
- PenNormal; { NECESSARY? }
- ControlArea(theRect);
- wasLocked := IsHandleLocked(fDataHandle); { Remember current lock state }
- IF NOT wasLocked THEN
- HLock(fDataHandle); { Because FillRect may move memory }
- IF fPreferColor THEN
- FillCRect(theRect, PixPatHandle(fDataHandle))
- ELSE
- FillRect(theRect, PatHandle(fDataHandle)^^);
- IF NOT wasLocked THEN
- HUnLock(fDataHandle); { restore handle's unlocked state }
- END
- END;
-
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPattern.ReleasePattern;
-
- BEGIN
- fRsrcID := kNoResource;
- IF fDataHandle <> NIL THEN
- BEGIN
- IF fPreferColor THEN
- DisposPixPat(PixPatHandle(fDataHandle))
- ELSE
- HPurge(fDataHandle);
- fDataHandle := NIL;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPattern.SetPattern(thePattern: Handle;
- redraw: BOOLEAN);
-
- BEGIN
- ReleasePattern;
- fDataHandle := thePattern;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TPattern.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TPattern', NIL, bClass);
- DoToField('fPreferColor', @fPreferColor, bBoolean);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fDataHandle', @fDataHandle, bHandle);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPicture.IPicture(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID: INTEGER);
-
- VAR
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
- fRsrcID := itsRsrcID;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- fDataHandle := GetPicture(fRsrcID);
- FailResError;
- Success(fi);
- END;
- ViewEnable(False, kDontRedraw); { Default is to not enable hit testing }
- fDefChoice := mPictureHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPicture.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fRsrcID := PictureTemplatePtr(itsParams)^.rsrcID;
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- fDataHandle := GetPicture(fRsrcID);
- FailResError;
- Success(fi);
- END;
- fDefChoice := mPictureHit;
-
- OffsetPtr(itsParams, SIZEOF(PictureTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPicture.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- pcPtr: PictureTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- pcPtr := PictureTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(PictureTemplate)));
-
- {$IFC qDebug}
- IF fRsrcID = kNoResource THEN
- WRITELN('Tried to write TPicture with no resource ID.');
- {$ENDC}
- pcPtr^.rsrcID := fRsrcID;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPicture.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'pict'; gWResType := 'TPicture';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TPicture.Free; OVERRIDE;
-
- BEGIN
- ReleasePicture;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPicture.Draw(area: Rect); OVERRIDE;
-
- VAR
- oldState: SignedByte;
- theRect: Rect;
-
- BEGIN
- IF fDataHandle <> NIL THEN
- BEGIN
- IF fRsrcID <> kNoResource THEN
- LoadResource(Handle(fDataHandle));
- IF fDataHandle^ <> NIL THEN { If there's room for the picture… }
- BEGIN
- ControlArea(theRect);
- oldState := GetHandleBits(Handle(fDataHandle));
- HNoPurge(Handle(fDataHandle));
- PenNormal; { ??? NECESSARY ??? }
- DrawPicture(fDataHandle, theRect);
- SetHandleBits(Handle(fDataHandle), oldState);
- END;
- END;
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPicture.ReleasePicture;
-
- BEGIN
- fRsrcID := kNoResource;
- IF fDataHandle <> NIL THEN
- BEGIN
- HPurge(Handle(fDataHandle));
- fDataHandle := NIL;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPicture.SetPicture(thePicture: PicHandle;
- redraw: BOOLEAN);
-
- BEGIN
- ReleasePicture;
- fDataHandle := thePicture;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TPicture.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TPicture', NIL, bClass);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fDataHandle', @fDataHandle, bHandle);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPopup.IPopup(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID, itsCurrentItem, itsItemOffset: INTEGER);
-
- VAR
- fi: FailInfo;
- aMenu: MenuHandle;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fMenuHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
-
- IF qNeedsHierarchicalMenus | gConfiguration.hasHierarchicalMenus THEN
- BEGIN
- fCurrentItem := Max(1, itsCurrentItem);
- fItemOffset := itsItemOffset;
- IF itsRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- aMenu := GetMenu(itsRsrcID);
- { Don't die because resource not found - just return NIL handle }
- FailResError;
- HNoPurge(Handle(aMenu));
- SetPopup(aMenu, itsRsrcID, itsCurrentItem, False);
- Success(fi);
- END
- ELSE
- BEGIN
- fRsrcID := kNoResource;
- fMenuID := kNoResource;
- END;
- fDefChoice := mPopupHit;
- END
- ELSE
- BEGIN
- {$IFC qDebug}
- ProgramBreak('Attempt to use popup menus on machine that doesn''t support them');
- {$ENDC}
- fShown := False; { What's reasonable here ??? }
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPopup.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- fi: FailInfo;
- aMenu: MenuHandle;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fMenuHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- {$IFC NOT qNeedsHierarchicalMenus}
- IF NOT gConfiguration.hasHierarchicalMenus THEN
- BEGIN
- {$IFC qDebug}
- ProgramBreak('Attempt to use popup menus on machine that doesn''t support them');
- {$ENDC}
- fShown := False; { What's reasonable here ??? }
- END
- ELSE
- {$ENDC}
- BEGIN
- WITH PopupTemplatePtr(itsParams)^ DO
- BEGIN
- fCurrentItem := Max(1, currentItem);
- fItemOffset := itemOffset;
- fRsrcID := rsrcID;
- IF rsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- aMenu := GetMenu(rsrcID);
- { Don't die because resource not found - just return NIL handle }
- FailResError;
- IF aMenu <> NIL THEN
- HNoPurge(Handle(aMenu));
- SetPopup(aMenu, rsrcID, fCurrentItem, False);
- Success(fi);
- END
- ELSE
- fMenuID := kNoResource;
- END;
- fDefChoice := mPopupHit;
- END;
-
- OffsetPtr(itsParams, SIZEOF(PopupTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPopup.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- poPtr: PopupTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- poPtr := PopupTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(PopupTemplate)));
-
- WITH poPtr^ DO
- BEGIN
- {$IFC qDebug}
- IF fRsrcID = kNoResource THEN
- ProgramBreak('Tried to write TPopup with no resource ID.');
- {$ENDC}
- rsrcID := fRsrcID;
- currentItem := fCurrentItem;
- itemOffset := fItemOffset;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TPopup.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'popp'; gWResType := 'TPopup';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TPopup.Free; OVERRIDE;
-
- BEGIN
- ReleasePopup;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TPopup.AdjustBotRight;
-
- VAR
- newHeight: INTEGER;
- newWidth: INTEGER;
- theFontInfo: FontInfo;
-
- BEGIN
- IF fMenuHandle <> NIL THEN
- BEGIN
- CalcMenuSize(fMenuHandle);
- newWidth := fMenuHandle^^.menuWidth + fItemOffset + fInset.left + fInset.right + 3;
-
- GetTextStyleFontInfo(gSystemStyle, theFontInfo);
-
- WITH theFontInfo DO
- newHeight := ascent + descent + leading + fInset.top + fInset.bottom + 3;
-
- Resize(newWidth, newHeight, kDontInvalidate);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.CalcLabelRect(VAR theRect: Rect);
-
- VAR
- theLabel: Str255;
-
- BEGIN
- ControlArea(theRect);
- InsetRect(theRect, 1, 1);
- WITH theRect DO
- BEGIN
- right := left + fItemOffset - 1; { adjust right }
- bottom := bottom - 1; { adjust bottom }
- theLabel := fMenuHandle^^.menuData; { fetch the title of the menu }
- left := Max(left, right - StringWidth(theLabel) - 2); { adjust left }
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.CalcMenuRect(VAR theRect: Rect);
-
- BEGIN
- ControlArea(theRect);
- InsetRect(theRect, 1, 1);
- WITH theRect DO
- BEGIN
- left := left + fItemOffset;
- {WITH botRight DO
- BEGIN
- h := h - 1;
- v := v - 1;
- END;}
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TPopup.DoMouseCommand(VAR theMouse: Point;
- VAR info: EventInfo;
- VAR hysteresis: Point): TCommand; OVERRIDE;
-
- VAR
- newChoice: INTEGER;
- result: LONGINT;
- menuPt: Point;
- aMenuHandle: MenuHandle;
- labelRect: Rect;
- menuRect: Rect;
- oldFColor: RGBColor;
- oldBkColor: RGBColor;
- newFColor: RGBColor;
- newBkColor: RGBColor;
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- DeleteMenu(fMenuID);
- SetIfColor(oldFColor); SetIfBkColor(oldBkColor);
- END;
-
- BEGIN
- DoMouseCommand := NIL;
- CalcLabelRect(labelRect);
- CalcMenuRect(menuRect); { ??? test if theMouse is in menuRect ??? }
-
- IF fMenuHandle <> NIL THEN
- BEGIN
- MAInsertMenu(fMenuHandle, hierMenu); { MAInsertMenu ensures colors are set }
- { Save the old colors, fetch the item colors, and draw the popup box }
- GetIfColor(oldFColor); GetIfBkColor(oldBkColor);
- GetMenuColors(menuRect, fMenuID, 0, newFColor, newBkColor);
- SetIfColor(newBkColor); SetIfBkColor(newFColor);
- DrawLabel(labelRect);
-
- IF (fRsrcID <> kNoResource) THEN
- IF qNeedsColorQD | gConfiguration.hasColorQD THEN
- aMenuHandle := GetResMenu(fRsrcID); { Reloads color tables! }
- WITH menuRect DO
- SetPt(menuPt, left, top); { Don't overwrite stuff next to the label }
- LocalToGlobal(menuPt);
- CalcMenuSize(fMenuHandle); { Fix for Menu Manager bug }
-
- SetIfColor(oldFColor); SetIfBkColor(oldBkColor);
- InsetRect(menuRect, - 1, - 1);
- EraseRect(menuRect);
-
- result := PopUpMenuSelect(fMenuHandle, menuPt.v, menuPt.h, fCurrentItem);
- newChoice := LoWord(result);
- SetIfColor(newFColor); SetIfBkColor(newBkColor);
- DrawLabel(labelRect);
- IF (HiWord(result) <> 0) & (newChoice <> fCurrentItem) THEN
- BEGIN
- SetCurrentItem(newChoice, kRedraw);
- CatchFailures(fi, HandleFailure);
- DoChoice(SELF, fDefChoice);
- Success(fi);
- END
- ELSE
- SetCurrentItem(fCurrentItem, kRedraw);
- DeleteMenu(fMenuID);
- SetIfColor(oldFColor); SetIfBkColor(oldBkColor);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.Draw(area: Rect); OVERRIDE;
-
- VAR
- aRect: Rect;
- oldFColor: RGBColor;
- oldBkColor: RGBColor;
- newFColor: RGBColor;
- newBkColor: RGBColor;
-
- BEGIN
- IF fMenuHandle <> NIL THEN
- BEGIN
- MAInsertMenu(fMenuHandle, hierMenu); { MAInsertMenu ensures colors are set }
- { Erase the whole menu first }
- ControlArea(aRect);
- IF SectRect(area, aRect, aRect) THEN
- BEGIN
- { EraseRect(aRect); }
-
- { Save the old colors, fetch the item colors, and draw the popup box }
- GetIfColor(oldFColor); GetIfBkColor(oldBkColor);
- CalcMenuRect(aRect);
- GetMenuColors(aRect, fMenuID, fCurrentItem, newFColor, newBkColor);
- SetIfColor(newFColor); SetIfBkColor(newBkColor);
- DrawPopupBox(area);
-
- { Fetch the title colors, and draw it }
- GetMenuColors(aRect, fMenuID, 0, newFColor, newBkColor);
- SetIfColor(newFColor); SetIfBkColor(newBkColor);
- DrawLabel(area);
-
- { Reset colors to their original state }
- SetIfColor(oldFColor); SetIfBkColor(oldBkColor);
- END;
- DeleteMenu(fMenuID);
- END;
-
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.DrawLabel(area: Rect);
-
- VAR
- labelRect: Rect;
- theLabel: Str255;
-
- BEGIN
- CalcLabelRect(labelRect);
- IF SectRect(area, labelRect, area) THEN
- BEGIN
-
- {$IFC qDebug}
- AssumeFocused;
- {$ENDC}
-
- theLabel := fMenuHandle^^.menuData; { Fetch the title of the menu }
- IF Length(theLabel) > 0 THEN
- BEGIN
- EraseRect(labelRect); { Might be switching colors }
- MADrawString(@theLabel, labelRect, teJustSystem);
- END;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.DrawPopupBox(area: Rect);
-
- CONST
- ShadowedFrame = [adnLineTop, adnLineLeft, adnLineBottom, adnLineRight, adnShadow];
- leftSlop = 15; { should be 13 to image like it used to
- (off by 2 pixels) at 15 it images exactly
- the same when popped up or not. }
- rightSlop = 1;
- botSlop = 6;
- kMinWidth = 0;
-
- VAR
- wid: INTEGER;
- newWid: INTEGER;
- newLen: INTEGER;
- menuRect: Rect;
- colorRect: Rect;
- theItemRect: Rect;
- theItem: Str255;
- theFontInfo: FontInfo;
-
- BEGIN
- CalcMenuRect(menuRect);
- GetItem(fMenuHandle, fCurrentItem, theItem);
- WITH menuRect DO
- BEGIN
- IF NOT EmptyRect(menuRect) THEN
- BEGIN
- InsetRect(menuRect, - 1, - 1);
- IF SectRect(area, menuRect, colorRect) THEN
- BEGIN
- IF (theItem <> '') THEN
- BEGIN
- wid := Max(kMinWidth, (right - left) - (leftSlop + rightSlop));
- newWid := StringWidth(theItem);
- IF newWid > wid THEN
- BEGIN
- newLen := Length(theItem);
-
- REPEAT
- theItem[newLen] := '…';
- theItem[0] := CHR(newLen);
- newWid := StringWidth(theItem);
- newLen := PRED(newLen);
- UNTIL (newWid <= wid) | (newLen = 0);
-
- END;
- END;
-
- PenNormal;
-
- {$IFC qDebug}
- AssumeFocused;
- {$ENDC}
-
- WITH colorRect DO
- BEGIN
- right := MIN(right, menuRect.right - 1);
- bottom := MIN(bottom, menuRect.bottom - 1);
- END;
- EraseRect(colorRect); { this "paints" the background }
-
- GetFontInfo(theFontInfo);
- WITH theFontInfo DO
- SetRect(theItemRect, left + leftSlop, bottom -
- botSlop - ascent, { top computed based on the bottom - text
- height }
- right - rightSlop, bottom - botSlop + descent);
- MADrawString(@theItem, theItemRect, teJustSystem);
-
- SetIfColor(gRGBBlack);
- WITH botRight DO
- BEGIN
- h := h - 1;
- v := v - 1;
- END;
- FrameRect(menuRect);
- MoveTo(left + 3, bottom);
- LineTo(right, bottom);
- LineTo(right, top + 3);
- END;
- END;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- FUNCTION TPopup.GetCurrentItem: INTEGER;
-
- BEGIN
- GetCurrentItem := fCurrentItem;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPopup.GetItemText(item: INTEGER;
- VAR theText: Str255);
-
- BEGIN
- IF fMenuHandle <> NIL THEN
- GetItem(fMenuHandle, item, theText)
- ELSE
- theText := '';
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPopup.ReleasePopup;
-
- BEGIN
- IF fMenuHandle <> NIL THEN
- BEGIN
- DisposeMenu(fMenuHandle);
- fMenuHandle := NIL;
- END;
- fMenuID := kNoResource;
- fCurrentItem := 0;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TPopup.SetCurrentItem(item: INTEGER;
- redraw: BOOLEAN);
-
- VAR
- menuRect: Rect;
- newFColor: RGBColor;
- newBkColor: RGBColor;
-
- BEGIN
- IF (fMenuHandle <> NIL) & (item <> fCurrentItem) THEN
- BEGIN
- IF fCurrentItem <> 0 THEN
- SetItemMark(fMenuHandle, fCurrentItem, ' ');
- IF item <> 0 THEN
- SetItemMark(fMenuHandle, item, CHR(checkMark));
- fCurrentItem := item;
- END;
- IF redraw & Focus & IsVisible THEN
- BEGIN
- GetQDExtent(menuRect);
- GetMenuColors(menuRect, fMenuID, item, newFColor, newBkColor);
- SetIfColor(newFColor); SetIfBkColor(newBkColor);
- DrawPopupBox(menuRect);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TPopup.SetPopup(theMenu: MenuHandle;
- theRsrcID, currentItem: INTEGER;
- redraw: BOOLEAN);
-
- VAR
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- ReleasePopup;
- IF theMenu <> NIL THEN
- BEGIN
- IF theRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- DetachResource(Handle(theMenu));
- FailResError;
- Success(fi);
- END;
- fMenuHandle := theMenu;
- fMenuID := theMenu^^.menuID;
- END;
- fRsrcID := theRsrcID;
- SetCurrentItem(Max(1, currentItem), kDontRedraw);
- AdjustBotRight;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TPopup.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TPopup', NIL, bClass);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fMenuID', @fMenuID, bInteger);
- DoToField('fMenuHandle', @fMenuHandle, bHandle);
- DoToField('fCurrentItem', @fCurrentItem, bInteger);
- DoToField('fItemOffset', @fItemOffset, bInteger);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S TEOpen}
-
- PROCEDURE TDialogTEView.IDialogTEView(itsDocument: TDocument; itsSuperView: TView; itsLocation,
- itsSize: VPoint; itsHDeterminer,
- itsVDeterminer: SizeDeterminer; itsInset: Rect;
- itsTextStyle: TextStyle; itsJustification: INTEGER;
- itsStyleType, itsAutoWrap: BOOLEAN);
-
- BEGIN
- fEditText := NIL; { We don't own this reference but we don't want an invalid one either }
- fScroller := NIL;
-
- ITEView(itsDocument, itsSuperView, itsLocation, itsSize, itsHDeterminer, itsVDeterminer,
- itsInset, itsTextStyle, itsJustification, itsStyleType, itsAutoWrap);
-
- fFreeText := TRUE;
-
- fScroller := MakeScroller;
- IF fScroller <> NIL THEN
- fScroller.AddSubView(SELF);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S TEOpen}
-
- PROCEDURE TDialogTEView.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
-
- BEGIN
- fEditText := NIL; { We don't own this reference but we don't
- want an invalid one either }
- fScroller := NIL;
- INHERITED IRes(itsDocument, itsSuperView, itsParams);
-
- fScroller := MakeScroller;
- IF fScroller <> NIL THEN
- fScroller.AddSubView(SELF);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S TEClose}
-
- PROCEDURE TDialogTEView.Free; OVERRIDE;
-
-
- BEGIN
- if fScroller <> NIL THEN
- BEGIN
- fScroller.RemoveSubView(SELF);
- FreeIfObject(fScroller);
- fScroller := NIL;
- END;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TDialogTEView.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TDialogTEView', NIL, bClass);
- DoToField('fEditText', @fEditText, bObject);
- DoToField('fScroller', @fScroller, bObject);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TDialogTEView.InstallEditText(theEditText: TEditText;
- selectChars: BOOLEAN);
-
- VAR
- theText: Str255;
- aTextStyle: TextStyle;
- theControlArea: Rect;
- validExtent: VRect;
- hadPendingUpdate: Boolean;
-
- BEGIN
- IF fEditText <> NIL THEN
- BEGIN
- fEditText.RemoveSubView(fScroller);
- fEditText := NIL;
- END;
-
- IF theEditText <> NIL THEN
- BEGIN
- fControlChars := theEditText.fControlChars;
- fMaxChars := theEditText.fMaxChars;
- fInset := gZeroRect;
- hadPendingUpdate := theEditText.HasPendingUpdate;
-
- SetJustification(theEditText.fJust, kDontRedraw);
- ChangeWrap(theEditText.fAutoWrap, kDontRedraw);
-
- aTextStyle := theEditText.fTextStyle;
- SetOneStyle(0, 0, doAll, aTextStyle, kDontRedraw);
-
- theEditText.ControlArea(theControlArea);
-
- theEditText.AddSubView(fScroller);{ my scroller }
-
- IF fAutoWrap THEN
- fSizeDeterminer[h] := sizeSuperView
- ELSE
- fSizeDeterminer[h] := sizeVariable; { Let the width vary with the number of characters }
-
- WITH theControlArea DO
- BEGIN
- fSuperView.Resize(right - left, bottom - top, kDontInvalidate);
- fSuperView.Locate(left, top, kDontInvalidate);
- END;
-
- theEditText.GetText(theText);
- SetText(theText);
- RecalcText;
- SynchView(kDontRedraw);
- AdjustSize;
-
- { Make the scroller's thinking match the display that the user already sees }
- fScroller.fTranslation.h := 0;
- CASE GetActualJustification(fJustification) OF
- teJustLeft, teForceLeft:
- fScroller.fTranslation.v := 0;
- teJustRight: { Right brain thinkers… left brain thinkers?? }
- TScroller(fSuperView).fTranslation.h := fScroller.fMaxTranslation.h;
- teJustCenter:
- fScroller.fTranslation.h := fScroller.fMaxTranslation.h DIV 2;
- END;
- theEditText.InvalidateFocus;
-
- IF selectChars THEN
- SetSelect(0, MAXINT, fHTE)
- ELSE
- SetSelect(0, 0, fHTE); { Caller will set the selection. }
-
- BeInScroller(fScroller);
-
- { Make my enable and my scroller's enable match my new superview }
- ViewEnable(theEditText.IsViewEnabled, kDontRedraw);
- fScroller.ViewEnable(theEditText.IsViewEnabled, kDontRedraw);
- fScroller.fRespondsToFunctionKeys := FALSE; { !!! need a better way to let enclosing
- dialog scroll by function keys if necessary }
-
- { Revalidate my extent to eliminate the flicker created by resizing the scrollers }
- IF NOT hadPendingUpdate & Focus THEN
- BEGIN
- GetExtent(validExtent);
- ValidVRect(validExtent);
- END;
- END;
-
- fEditText := theEditText;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TDialogTEView.InstallSelection(wasActive, beActive: BOOLEAN); OVERRIDE;
-
- BEGIN
- { If we're deselecting a field and it's been scrolled, invalidate it
- so that it is redrawn correctly.}
- IF NOT beActive THEN
- IF fScroller.fTranslation.v <> 0 THEN
- ForceRedraw
- ELSE
- CASE GetActualJustification(fJustification) OF
- teJustLeft, teForceLeft:
- BEGIN
- IF fScroller.fTranslation.h <> 0 THEN
- ForceRedraw;
- END;
- teJustRight:
- BEGIN
- IF fScroller.fTranslation.h <> fScroller.fMaxTranslation.h THEN
- ForceRedraw;
- END;
- teJustCenter:
- BEGIN
- IF fScroller.fTranslation.h <> (fScroller.fMaxTranslation.h DIV 2) THEN
- ForceRedraw;
- END;
- END;
-
- INHERITED InstallSelection(wasActive, beActive);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TDialogTEView.ComputeSize(VAR newSize: VPoint); OVERRIDE;
-
- BEGIN
- INHERITED ComputeSize(newSize);
-
- IF NOT fAutoWrap THEN
- CASE fSizeDeterminer[h] OF
- sizeVariable:
- { TTEView already computed the variable size, bump it up to at leat the scroller's
- size so that the cursor is claimed for the EditText and the user can click anywhere. }
- IF NOT fStyleType THEN
- newSize.h := Max(fScroller.fSize.h, newSize.h);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S TEOpen}
-
- FUNCTION TDialogTEView.MakeScroller: TScroller;
- { Must return a scroller. !!! enhance the TDialogTEView to be able to function without a scroller }
- VAR
- aScroller: TScroller;
-
- BEGIN
- aScroller := NIL;
- New(aScroller);
- FailNil(aScroller);
- aScroller.IScroller(NIL, gZeroVPt, gZeroVPt, sizeRelSuperView, sizeRelSuperView, 0, 0,
- NOT kWantHScrollBar, NOT kWantVScrollBar);
- MakeScroller := aScroller;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TStaticText.IStaticText(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsHSizeDet, itsVSizeDet: SizeDeterminer;
- itsRsrcID, itsIndex: INTEGER);
-
- VAR
- aString: Str255;
- fi: FailInfo;
-
- PROCEDURE HandleFailure(error: OSErr;
- message: LONGINT);
-
- BEGIN
- Free;
- END;
-
- BEGIN
- fDataHandle := NIL;
- IControl(itsSuperView, itsLocation, itsSize, itsHSizeDet, itsVSizeDet);
- fRsrcID := itsRsrcID;
- fIndex := itsIndex;
- fJust := teJustSystem; { Default to system justification }
- fAutoWrap := TRUE; { Default to compatibility with 2.0 }
- IF fRsrcID <> kNoResource THEN
- BEGIN
- CatchFailures(fi, HandleFailure);
- GetIndString(aString, fRsrcID, fIndex);
- FailResError;
- Success(fi);
- SetText(aString, kDontRedraw);
- END;
- ViewEnable(False, kDontRedraw); { Default is to not enable hit testing }
- fDefChoice := mStaticTextHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TStaticText.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- fRsrcID := kNoResource;
- fIndex := 0;
- fDataHandle := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fAutoWrap := TRUE; { Default to compatibility with 2.0 }
- fDefChoice := mStaticTextHit;
- WITH StaticTextTemplatePtr(itsParams)^ DO
- BEGIN
- fJust := just;
- SetText(data, kDontRedraw);
- END;
-
- OffsetPtrWStr(itsParams, SIZEOF(StaticTextTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TStaticText.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- theText: Str255;
- stPtr: StaticTextTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- GetText(theText);
-
- stPtr := StaticTextTemplatePtr(ExpandPtrWStr(theResource, itsParams, SIZEOF(StaticTextTemplate),
- Length(theText)));
-
- WITH stPtr^ DO
- BEGIN
- just := fJust;
- { data := theText; }
- CopyStr255(theText, PRStr(data));
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TStaticText.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'stat'; gWResType := 'TStaticText';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TStaticText.Free; OVERRIDE;
-
- BEGIN
- ReleaseText;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TStaticText.ChangeWrap(newAutoWrap, redraw: BOOLEAN);
-
- BEGIN
- fAutoWrap := newAutoWrap;
- IF Redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TStaticText.DoSubstitution(VAR theText: Str255);
-
- VAR
- aDialogView: TDialogView;
-
- BEGIN
- aDialogView := TDialogView(GetDialogView);
- IF aDialogView <> NIL THEN
- aDialogView.ReplaceText(theText);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TStaticText.Draw(area: Rect); OVERRIDE;
-
- VAR
- theRect: Rect;
- oldColor: RGBColor;
- theText: Str255;
- aTextStyle: TextStyle;
-
- BEGIN
- IF fDataHandle <> NIL THEN
- BEGIN
- GetText(theText);
- DoSubstitution(theText); { Make the substitution if desired }
- ControlArea(theRect);
- PenNormal; { ??? NECESSARY ??? }
- GetIfColor(oldColor);
- aTextStyle := fTextStyle;
- SetPortTextStyle(aTextStyle);
- ImageText(Ptr(ORD4(@theText) + 1), Length(theText), theRect, fJust);
- SetIfColor(oldColor);
- END;
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TStaticText.GetText(VAR theText: Str255);
-
- BEGIN
- IF fDataHandle <> NIL THEN
- { theText := fDataHandle^^ }
- CopyStr255(fDataHandle^^, @theText)
- ELSE
- theText := '';
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TStaticText.ImageText(text: Ptr;
- Length: LONGINT;
- box: Rect;
- just: INTEGER);
-
- BEGIN
- MATextBox(text, Length, box, just, fAutoWrap, NIL, kNoEraseFirst, kSpaceForCaret);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TStaticText.ReleaseText;
-
- BEGIN
- Handle(fDataHandle) := DisposeIfHandle(fDataHandle);
-
- fRsrcID := kNoResource;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TStaticText.SetJustification(theJust: INTEGER;
- redraw: BOOLEAN);
-
- BEGIN
- fJust := theJust;
- IF redraw THEN
- ForceRedraw;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TStaticText.SetText(theText: Str255;
- redraw: BOOLEAN);
-
- VAR
- area: Rect;
-
- BEGIN
- IF (fDataHandle = NIL) | (theText <> fDataHandle^^) THEN
- BEGIN
- ReleaseText;
- fDataHandle := NewString(theText);
- IF MemError <> noErr THEN
- fDataHandle := NIL;
- IF redraw & Focus & IsVisible THEN
- BEGIN
- ControlArea(area);
- EraseRect(area);
- Draw(area);
- END;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TStaticText.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- VAR
- aString: Str255;
-
- BEGIN
- DoToField('TStaticText', NIL, bClass);
- DoToField('fRsrcID', @fRsrcID, bInteger);
- DoToField('fIndex', @fIndex, bInteger);
- DoToField('fDataHandle', @fDataHandle, bHandle);
- IF fDataHandle <> NIL THEN
- BEGIN
- aString := fDataHandle^^;
- DoToField('fDataHandle^^', @aString, bString);
- END;
- DoToField('fJust', @fJust, bInteger);
- DoToField('fAutoWrap', @fAutoWrap, bBoolean);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TEditText.IEditText(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsMaxChars: INTEGER);
-
- BEGIN
- fTEView := NIL;
- IStaticText(itsSuperView, itsLocation, itsSize, sizeFixed, sizeFixed, kNoResource, 0);
-
- fAutoWrap := FALSE; { Default to compatibility with 2.0
- Never the twain shall meet.}
- fMaxChars := itsMaxChars;
- fControlChars := [chLeft, chRight, chUp, chDown, chBackspace];
- fTextStyle := gSystemStyle;
- Inset(3, 3, kDontRedraw); { Default is a little, teeny inset… }
- fPenSize := Point($00010001); { …and a thin frame }
- fAdornment := kFrame;
- ViewEnable(TRUE, kDontRedraw);
- fDefChoice := mEditTextHit;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TEditText.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- fTEView := NIL;
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- fAutoWrap := FALSE; { Default to compatibility with 2.0
- Never the twain shall meet.}
- WITH EditTextTemplatePtr(itsParams)^ DO
- BEGIN
- fMaxChars := maxChars;
- fControlChars := controlChars;
- END;
- fDefChoice := mEditTextHit;
-
- OffsetPtr(itsParams, SIZEOF(EditTextTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgClose}
-
- PROCEDURE TEditText.Free; OVERRIDE;
-
- BEGIN
- IF fTEView <> NIL THEN
- BEGIN
- fTEView.InstallEditText(NIL, False);
- fTEView := NIL
- END;
-
- INHERITED Free;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TEditText.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- edPtr: EditTextTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- edPtr := EditTextTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(EditTextTemplate)));
-
- WITH edPtr^ DO
- BEGIN
- maxChars := fMaxChars;
- controlChars := fControlChars;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TEditText.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'edit'; gWResType := 'TEditText';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.ChangeWrap(newAutoWrap, redraw: BOOLEAN); OVERRIDE;
-
- BEGIN
- INHERITED ChangeWrap(newAutoWrap, redraw);
- IF fTEView <> NIL THEN
- fTEView.ChangeWrap(newAutoWrap, redraw)
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TEditText.HandleMouseDown(theMouse: VPoint;
- VAR info: EventInfo;
- VAR hysteresis: Point;
- VAR theCommand: TCommand): BOOLEAN; OVERRIDE;
-
- BEGIN
- IF IsViewEnabled & (gTarget <> fTEView) THEN { Get the floating TE installed if necessary }
- DoChoice(SELF, fDefChoice);
-
- HandleMouseDown := INHERITED HandleMouseDown(theMouse, info, hysteresis, theCommand);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.DoSubstitution(VAR theText: Str255); OVERRIDE;
-
- BEGIN
- { Default action is for editable text items is not to do any substitions }
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.Draw(area: Rect); OVERRIDE;
-
- VAR
- theRect: Rect;
-
- BEGIN
- IF fTEView <> NIL THEN
- BEGIN
- GetQDExtent(theRect);
- Adorn(theRect, fPenSize, fAdornment);
- END
- ELSE
- INHERITED Draw(area);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TEditText.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TEditText', NIL, bClass);
- DoToField('fMaxChars', @fMaxChars, bInteger);
- DoToField('fTEView', @fTEView, bObject);
- DoToField('fControlChars', @fControlChars, bHexLongInt);
-
- INHERITED Fields(DoToField);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.GetText(VAR theText: Str255); OVERRIDE;
-
- VAR
- theChars: Handle;
- numberOfChars: INTEGER;
-
- BEGIN
- IF fTEView = NIL THEN
- INHERITED GetText(theText)
- ELSE
- BEGIN
- theChars := fTEView.ExtractText;
- numberOfChars := MIN(255, GetHandleSize(theChars));
- {$Push} {$R-}
- theText[0] := CHR(numberOfChars);
- {$Pop}
- BlockMove(Ptr(theChars^), Ptr(ORD4(@theText) + 1), numberOfChars);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
-
- PROCEDURE TEditText.ImageText(text: Ptr;
- Length: LONGINT;
- box: Rect;
- just: INTEGER); OVERRIDE;
-
- BEGIN
- IF Length >= 0 THEN
- MATextBox(text, Length, box, just, fAutoWrap , NIL, kNoEraseFirst,
- kSpaceForCaret);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TEditText.RestartEdit(restartText: Str255);
-
- VAR
- area: Rect;
-
- BEGIN
- IF fTEView.Focus THEN { First, attempt to focus the TEView }
- BEGIN
- ClipRect(gZeroRect); { Prevent TE from mucking up the hilite with
- a stinking insertion point }
-
- InstallSelection(TRUE, False); { Deactivate the selection }
- SetText(restartText, kDontRedraw); { Set the text to previous value }
- SetSelection(0, MAXINT, kDontRedraw); { Select all characters }
-
- InstallSelection(False, TRUE); { Activate the selection }
- InvalidateFocus; { Make sure we re-focus }
- fTEView.ForceRedraw;
- END
- ELSE
- SetText(restartText, kDontRedraw); { Just set the text if we can't focus }
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TEditText.SetJustification(theJust: INTEGER;
- redraw: BOOLEAN);
-
- BEGIN
- IF fTEView <> NIL THEN
- fTEView.SetJustification(theJust, redraw);
- INHERITED SetJustification(theJust, redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.SetSelection(selStart, selEnd: INTEGER;
- redraw: BOOLEAN);
-
- BEGIN
- IF fTEView <> NIL THEN
- BEGIN
- IF redraw & fTEView.Focus & fTEView.IsVisible THEN
- BEGIN
- TESetSelect(selStart, selEnd, fTEView.fHTE);
- END
- ELSE
- SetSelect(selStart, selEnd, fTEView.fHTE);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TEditText.SetText(theText: Str255;
- redraw: BOOLEAN); OVERRIDE;
-
- VAR
- currentText: Str255;
- area: Rect;
-
- BEGIN
- IF fTEView <> NIL THEN
- BEGIN
- GetText(currentText);
- IF currentText <> theText THEN
- BEGIN
- fTEView.SetText(theText);
- fTEView.RecalcText;
- fTEView.SynchView(kDontRedraw);
- IF redraw & Focus & IsVisible THEN
- BEGIN
- ControlArea(area);
- EraseRect(area);
- DrawContents;
- END;
- END;
- END
- ELSE
- INHERITED SetText(theText, redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- PROCEDURE TEditText.InstallSelection(wasActive, beActive: BOOLEAN); OVERRIDE;
-
- BEGIN
- IF fTEView <> NIL THEN
- fTEView.InstallSelection(wasActive, beActive);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TEditText.StartEdit(selectChars: BOOLEAN;
- theTEView: TDialogTEView);
-
- VAR
- myExtent: VRect;
- minToSee: Point;
- itsWindow: TWindow;
-
- BEGIN
- IF theTEView = NIL THEN
- BEGIN
- {$IFC qDebug}
- ProgramBreak('the TEView is nil.');
- {$ENDC}
- EXIT(StartEdit);
- END;
-
- theTEView.InstallEditText(SELF, selectChars);
- fTEView := theTEView;
- itsWindow := GetWindow; { Set the window's target, which sets }
- IF itsWindow <> NIL THEN { …the application's target if it is }
- itsWindow.SetTarget(theTEView); { …the front window. }
-
- GetExtent(myExtent);
- InsetVRect(myExtent, - 10, - 10);
- minToSee.h := MIN(fSize.h + 10, kMaxCoord);
- minToSee.v := MIN(fSize.v + 10, kMaxCoord);
-
- RevealRect(myExtent, minToSee, kVisible); { Make me visible }
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TEditText.StopEdit;
-
- VAR
- aString: Str255;
-
- BEGIN
- IF fTEView <> NIL THEN
- BEGIN
- GetText(aString); { Must get the text before calling
- InstallEditText }
- fTEView.InstallSelection(TRUE, False);
- fTEView.InstallEditText(NIL, False);
- fTEView := NIL;
- SetText(aString, kDontRedraw);
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TEditText.Validate: LONGINT;
-
- VAR
- validateResult: LONGINT;
-
- BEGIN
- validateResult := INHERITED Validate;
- IF (validateResult = kValidValue) & (fTEView <> NIL) & (GetHandleSize(fTEView.fText) >
- fMaxChars) THEN
- validateResult := kTooManyCharacters;
- Validate := validateResult;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TNumberText.INumberText(itsSuperView: TView;
- itsLocation, itsSize: VPoint;
- itsValue, itsMinimum, itsMaximum: LONGINT);
-
- VAR
- aString: Str255;
-
- BEGIN
- IEditText(itsSuperView, itsLocation, itsSize, 255);
- {$IFC qDebug}
- IF itsMinimum > itsMaximum THEN
- WRITELN('Minimum value specified is greater than maximum for TNumberText.');
- {$ENDC}
- fMinimum := itsMinimum;
- fMaximum := itsMaximum;
- NumToString(itsValue, aString);
- SetText(aString, kDontRedraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgOpen}
-
- PROCEDURE TNumberText.IRes(itsDocument: TDocument;
- itsSuperView: TView;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- aString: Str255;
-
- BEGIN
- INHERITED IRes(NIL, itsSuperView, itsParams);
-
- WITH NumberTextTemplatePtr(itsParams)^ DO
- BEGIN
- NumToString(value, aString);
- SetText(aString, kDontRedraw);
- {$IFC qDebug}
- IF minimum > maximum THEN
- WRITELN('Minimum value specified is greater than maximum for TNumberText.');
- {$ENDC}
- fMinimum := minimum;
- fMaximum := maximum;
- END;
-
- OffsetPtr(itsParams, SIZEOF(NumberTextTemplate));
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TNumberText.WRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- VAR
- nmPtr: NumberTextTemplatePtr;
-
- BEGIN
- INHERITED WRes(theResource, itsParams);
-
- nmPtr := NumberTextTemplatePtr(ExpandPtr(theResource, itsParams, SIZEOF(NumberTextTemplate)));
-
- WITH nmPtr^ DO
- BEGIN
- value := GetValue;
- minimum := fMinimum;
- maximum := fMaximum;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S MAWriteRes}
-
- PROCEDURE TNumberText.WriteRes(theResource: ViewRsrcHndl;
- VAR itsParams: Ptr); OVERRIDE;
-
- BEGIN
- gWResSignature := 'nmbr'; gWResType := 'TNumberText';
- WRes(theResource, itsParams);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgRes}
-
- FUNCTION TNumberText.GetValue: LONGINT;
-
- VAR
- aString: Str255;
- theValue: LONGINT;
-
- BEGIN
- GetText(aString);
- StringToNum(aString, theValue);
- GetValue := theValue;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- PROCEDURE TNumberText.SetValue(newValue: LONGINT;
- redraw: BOOLEAN);
-
- VAR
- aString: Str255;
-
- BEGIN
- newValue := Max(fMinimum, MIN(fMaximum, newValue));
- NumToString(newValue, aString);
- SetText(aString, redraw);
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgNonRes}
-
- FUNCTION TNumberText.Validate: LONGINT; OVERRIDE;
-
- VAR
- theString: Str255;
- decRec: Decimal;
- extValue: Extended;
- index: INTEGER;
- validPrefix: BOOLEAN;
-
- BEGIN
- Validate := kValidValue;
-
- {!!! This really begs for a fRequired field to test when the string is left empty }
- { Then we would inform the user that an empty string is not a valid option. }
- { Also a fDefault field is necessary. GetValue would return fDefault rather }
- { than 0 when the string is empty. For now (2.0) we will not validate an empty
- { string and assume that if the user wants a value they will override. }
-
- GetText(theString);
- IF theString <> '' THEN
- BEGIN
- index := 1;
- Str2Dec(theString, index, decRec, validPrefix);
- IF validPrefix & (index > Length(theString)) & (decRec.exp >= 0) THEN
- BEGIN
- extValue := Dec2Num(decRec);
- IF extValue < fMinimum THEN
- Validate := kValueTooSmall
- ELSE IF extValue > fMaximum THEN
- Validate := kValueTooLarge;
- END
- ELSE
- Validate := kNonNumericCharacters;
- END;
- END;
-
- {--------------------------------------------------------------------------------------------------}
- {$S DlgFields}
-
- PROCEDURE TNumberText.Fields(PROCEDURE DoToField(fieldName: Str255;
- fieldAddr: Ptr;
- fieldType: INTEGER)); OVERRIDE;
-
- BEGIN
- DoToField('TNumberText', NIL, bClass);
- DoToField('fMinimum', @fMinimum, bLongInt);
- DoToField('fMaximum', @fMaximum, bLongInt);
-
- INHERITED Fields(DoToField);
- END;
-